home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / dejagnu.lha / dejagnu-1.0.1 / tcl / tclCmdIL.c < prev    next >
C/C++ Source or Header  |  1993-02-14  |  30KB  |  1,161 lines
  1. /* 
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright 1987-1991 Regents of the University of California
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  The University of California
  14.  * makes no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without
  16.  * express or implied warranty.
  17.  */
  18.  
  19. #include "tclInt.h"
  20.  
  21. /*
  22.  * Forward declarations for procedures defined in this file:
  23.  */
  24.  
  25. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  26.                 CONST VOID *second));
  27.  
  28. /*
  29.  *----------------------------------------------------------------------
  30.  *
  31.  * Tcl_IfCmd --
  32.  *
  33.  *    This procedure is invoked to process the "if" Tcl command.
  34.  *    See the user documentation for details on what it does.
  35.  *
  36.  * Results:
  37.  *    A standard Tcl result.
  38.  *
  39.  * Side effects:
  40.  *    See the user documentation.
  41.  *
  42.  *----------------------------------------------------------------------
  43.  */
  44.  
  45.     /* ARGSUSED */
  46. int
  47. Tcl_IfCmd(dummy, interp, argc, argv)
  48.     ClientData dummy;            /* Not used. */
  49.     Tcl_Interp *interp;            /* Current interpreter. */
  50.     int argc;                /* Number of arguments. */
  51.     char **argv;            /* Argument strings. */
  52. {
  53.     int i, result, value;
  54.  
  55.     i = 1;
  56.     while (1) {
  57.     /*
  58.      * At this point in the loop, argv and argc refer to an expression
  59.      * to test, either for the main expression or an expression
  60.      * following an "elseif".  The arguments after the expression must
  61.      * be "then" (optional) and a script to execute if the expression is
  62.      * true.
  63.      */
  64.  
  65.     if (i >= argc) {
  66.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  67.             argv[i-1], "\" argument", (char *) NULL);
  68.         return TCL_ERROR;
  69.     }
  70.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  71.     if (result != TCL_OK) {
  72.         return result;
  73.     }
  74.     i++;
  75.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  76.         i++;
  77.     }
  78.     if (i >= argc) {
  79.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  80.             argv[i-1], "\" argument", (char *) NULL);
  81.         return TCL_ERROR;
  82.     }
  83.     if (value) {
  84.         return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
  85.     }
  86.  
  87.     /*
  88.      * The expression evaluated to false.  Skip the command, then
  89.      * see if there is an "else" or "elseif" clause.
  90.      */
  91.  
  92.     i++;
  93.     if (i >= argc) {
  94.         return TCL_OK;
  95.     }
  96.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  97.         i++;
  98.         continue;
  99.     }
  100.     break;
  101.     }
  102.  
  103.     /*
  104.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  105.      * for an "else" clause.  We know that there's at least one more
  106.      * argument when we get here.
  107.      */
  108.  
  109.     if (strcmp(argv[i], "else") == 0) {
  110.     i++;
  111.     if (i >= argc) {
  112.         Tcl_AppendResult(interp,
  113.             "wrong # args: no script following \"else\" argument",
  114.             (char *) NULL);
  115.         return TCL_ERROR;
  116.     }
  117.     }
  118.     return Tcl_Eval(interp, argv[i], 0, (char **) NULL);
  119. }
  120.  
  121. /*
  122.  *----------------------------------------------------------------------
  123.  *
  124.  * Tcl_IncrCmd --
  125.  *
  126.  *    This procedure is invoked to process the "incr" Tcl command.
  127.  *    See the user documentation for details on what it does.
  128.  *
  129.  * Results:
  130.  *    A standard Tcl result.
  131.  *
  132.  * Side effects:
  133.  *    See the user documentation.
  134.  *
  135.  *----------------------------------------------------------------------
  136.  */
  137.  
  138.     /* ARGSUSED */
  139. int
  140. Tcl_IncrCmd(dummy, interp, argc, argv)
  141.     ClientData dummy;            /* Not used. */
  142.     Tcl_Interp *interp;            /* Current interpreter. */
  143.     int argc;                /* Number of arguments. */
  144.     char **argv;            /* Argument strings. */
  145. {
  146.     int value;
  147.     char *oldString, *result;
  148.     char newString[30];
  149.  
  150.     if ((argc != 2) && (argc != 3)) {
  151.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  152.         " varName ?increment?\"", (char *) NULL);
  153.     return TCL_ERROR;
  154.     }
  155.  
  156.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  157.     if (oldString == NULL) {
  158.     return TCL_ERROR;
  159.     }
  160.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  161.     Tcl_AddErrorInfo(interp,
  162.         "\n    (reading value of variable to increment)");
  163.     return TCL_ERROR;
  164.     }
  165.     if (argc == 2) {
  166.     value += 1;
  167.     } else {
  168.     int increment;
  169.  
  170.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  171.         Tcl_AddErrorInfo(interp,
  172.             "\n    (reading increment)");
  173.         return TCL_ERROR;
  174.     }
  175.     value += increment;
  176.     }
  177.     sprintf(newString, "%d", value);
  178.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  179.     if (result == NULL) {
  180.     return TCL_ERROR;
  181.     }
  182.     interp->result = result;
  183.     return TCL_OK; 
  184. }
  185.  
  186. /*
  187.  *----------------------------------------------------------------------
  188.  *
  189.  * Tcl_InfoCmd --
  190.  *
  191.  *    This procedure is invoked to process the "info" Tcl command.
  192.  *    See the user documentation for details on what it does.
  193.  *
  194.  * Results:
  195.  *    A standard Tcl result.
  196.  *
  197.  * Side effects:
  198.  *    See the user documentation.
  199.  *
  200.  *----------------------------------------------------------------------
  201.  */
  202.  
  203.     /* ARGSUSED */
  204. int
  205. Tcl_InfoCmd(dummy, interp, argc, argv)
  206.     ClientData dummy;            /* Not used. */
  207.     Tcl_Interp *interp;            /* Current interpreter. */
  208.     int argc;                /* Number of arguments. */
  209.     char **argv;            /* Argument strings. */
  210. {
  211.     register Interp *iPtr = (Interp *) interp;
  212.     int length;
  213.     char c;
  214.     Arg *argPtr;
  215.     Proc *procPtr;
  216.     Var *varPtr;
  217.     Command *cmdPtr;
  218.     Tcl_HashEntry *hPtr;
  219.     Tcl_HashSearch search;
  220.  
  221.     if (argc < 2) {
  222.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  223.         " option ?arg arg ...?\"", (char *) NULL);
  224.     return TCL_ERROR;
  225.     }
  226.     c = argv[1][0];
  227.     length = strlen(argv[1]);
  228.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  229.     if (argc != 3) {
  230.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  231.             argv[0], " args procname\"", (char *) NULL);
  232.         return TCL_ERROR;
  233.     }
  234.     procPtr = TclFindProc(iPtr, argv[2]);
  235.     if (procPtr == NULL) {
  236.         infoNoSuchProc:
  237.         Tcl_AppendResult(interp, "\"", argv[2],
  238.             "\" isn't a procedure", (char *) NULL);
  239.         return TCL_ERROR;
  240.     }
  241.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  242.         argPtr = argPtr->nextPtr) {
  243.         Tcl_AppendElement(interp, argPtr->name, 0);
  244.     }
  245.     return TCL_OK;
  246.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  247.     if (argc != 3) {
  248.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  249.             " body procname\"", (char *) NULL);
  250.         return TCL_ERROR;
  251.     }
  252.     procPtr = TclFindProc(iPtr, argv[2]);
  253.     if (procPtr == NULL) {
  254.         goto infoNoSuchProc;
  255.     }
  256.     iPtr->result = procPtr->command;
  257.     return TCL_OK;
  258.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  259.         && (length >= 2)) {
  260.     if (argc != 2) {
  261.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  262.             " cmdcount\"", (char *) NULL);
  263.         return TCL_ERROR;
  264.     }
  265.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  266.     return TCL_OK;
  267.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  268.         && (length >= 4)) {
  269.     if (argc > 3) {
  270.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  271.             " commands [pattern]\"", (char *) NULL);
  272.         return TCL_ERROR;
  273.     }
  274.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  275.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  276.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  277.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  278.         continue;
  279.         }
  280.         Tcl_AppendElement(interp, name, 0);
  281.     }
  282.     return TCL_OK;
  283.     } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
  284.         && (length >= 4)) {
  285.     if (argc != 3) {
  286.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  287.             " complete command\"", (char *) NULL);
  288.         return TCL_ERROR;
  289.     }
  290.     if (Tcl_CommandComplete(argv[2])) {
  291.         interp->result = "1";
  292.     } else {
  293.         interp->result = "0";
  294.     }
  295.     return TCL_OK;
  296.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  297.     if (argc != 5) {
  298.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  299.             argv[0], " default procname arg varname\"",
  300.             (char *) NULL);
  301.         return TCL_ERROR;
  302.     }
  303.     procPtr = TclFindProc(iPtr, argv[2]);
  304.     if (procPtr == NULL) {
  305.         goto infoNoSuchProc;
  306.     }
  307.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  308.         if (argPtr == NULL) {
  309.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  310.             "\" doesn't have an argument \"", argv[3],
  311.             "\"", (char *) NULL);
  312.         return TCL_ERROR;
  313.         }
  314.         if (strcmp(argv[3], argPtr->name) == 0) {
  315.         if (argPtr->defValue != NULL) {
  316.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  317.                 argPtr->defValue, 0) == NULL) {
  318.             defStoreError:
  319.             Tcl_AppendResult(interp,
  320.                 "couldn't store default value in variable \"",
  321.                 argv[4], "\"", (char *) NULL);
  322.             return TCL_ERROR;
  323.             }
  324.             iPtr->result = "1";
  325.         } else {
  326.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  327.                 == NULL) {
  328.             goto defStoreError;
  329.             }
  330.             iPtr->result = "0";
  331.         }
  332.         return TCL_OK;
  333.         }
  334.     }
  335.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  336.     char *p;
  337.     if (argc != 3) {
  338.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  339.             " exists varName\"", (char *) NULL);
  340.         return TCL_ERROR;
  341.     }
  342.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  343.  
  344.     /*
  345.      * The code below handles the special case where the name is for
  346.      * an array:  Tcl_GetVar will reject this since you can't read
  347.      * an array variable without an index.
  348.      */
  349.  
  350.     if (p == NULL) {
  351.         Tcl_HashEntry *hPtr;
  352.         Var *varPtr;
  353.  
  354.         if (strchr(argv[2], '(') != NULL) {
  355.         noVar:
  356.         iPtr->result = "0";
  357.         return TCL_OK;
  358.         }
  359.         if (iPtr->varFramePtr == NULL) {
  360.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  361.         } else {
  362.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  363.         }
  364.         if (hPtr == NULL) {
  365.         goto noVar;
  366.         }
  367.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  368.         if (varPtr->flags & VAR_UPVAR) {
  369.         varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  370.         }
  371.         if (!(varPtr->flags & VAR_ARRAY)) {
  372.         goto noVar;
  373.         }
  374.     }
  375.     iPtr->result = "1";
  376.     return TCL_OK;
  377.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  378.     char *name;
  379.  
  380.     if (argc > 3) {
  381.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  382.             " globals [pattern]\"", (char *) NULL);
  383.         return TCL_ERROR;
  384.     }
  385.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  386.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  387.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  388.         if (varPtr->flags & VAR_UNDEFINED) {
  389.         continue;
  390.         }
  391.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  392.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  393.         continue;
  394.         }
  395.         Tcl_AppendElement(interp, name, 0);
  396.     }
  397.     return TCL_OK;
  398.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  399.         && (length >= 2)) {
  400.     if (argc == 2) {
  401.         if (iPtr->varFramePtr == NULL) {
  402.         iPtr->result = "0";
  403.         } else {
  404.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  405.         }
  406.         return TCL_OK;
  407.     } else if (argc == 3) {
  408.         int level;
  409.         CallFrame *framePtr;
  410.  
  411.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  412.         return TCL_ERROR;
  413.         }
  414.         if (level <= 0) {
  415.         if (iPtr->varFramePtr == NULL) {
  416.             levelError:
  417.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  418.                 "\"", (char *) NULL);
  419.             return TCL_ERROR;
  420.         }
  421.         level += iPtr->varFramePtr->level;
  422.         }
  423.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  424.             framePtr = framePtr->callerVarPtr) {
  425.         if (framePtr->level == level) {
  426.             break;
  427.         }
  428.         }
  429.         if (framePtr == NULL) {
  430.         goto levelError;
  431.         }
  432.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  433.         iPtr->freeProc = (Tcl_FreeProc *) free;
  434.         return TCL_OK;
  435.     }
  436.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  437.         " level [number]\"", (char *) NULL);
  438.     return TCL_ERROR;
  439.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  440.         && (length >= 2)) {
  441.     if (argc != 2) {
  442.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  443.             " library\"", (char *) NULL);
  444.         return TCL_ERROR;
  445.     }
  446.     interp->result = getenv("TCL_LIBRARY");
  447.     if (interp->result == NULL) {
  448. #ifdef TCL_LIBRARY
  449.         interp->result = TCL_LIBRARY;
  450. #else
  451.         interp->result = "there is no Tcl library at this installation";
  452.         return TCL_ERROR;
  453. #endif
  454.     }
  455.     return TCL_OK;
  456.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  457.         && (length >= 2)) {
  458.     char *name;
  459.  
  460.     if (argc > 3) {
  461.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  462.             " locals [pattern]\"", (char *) NULL);
  463.         return TCL_ERROR;
  464.     }
  465.     if (iPtr->varFramePtr == NULL) {
  466.         return TCL_OK;
  467.     }
  468.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  469.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  470.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  471.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  472.         continue;
  473.         }
  474.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  475.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  476.         continue;
  477.         }
  478.         Tcl_AppendElement(interp, name, 0);
  479.     }
  480.     return TCL_OK;
  481.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
  482.     if (argc > 3) {
  483.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  484.             " procs [pattern]\"", (char *) NULL);
  485.         return TCL_ERROR;
  486.     }
  487.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  488.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  489.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  490.  
  491.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  492.         if (!TclIsProc(cmdPtr)) {
  493.         continue;
  494.         }
  495.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  496.         continue;
  497.         }
  498.         Tcl_AppendElement(interp, name, 0);
  499.     }
  500.     return TCL_OK;
  501.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  502.     if (argc != 2) {
  503.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  504.             argv[0], " script\"", (char *) NULL);
  505.         return TCL_ERROR;
  506.     }
  507.     if (iPtr->scriptFile != NULL) {
  508.         interp->result = iPtr->scriptFile;
  509.     }
  510.     return TCL_OK;
  511.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  512.     if (argc != 2) {
  513.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  514.             argv[0], " tclversion\"", (char *) NULL);
  515.         return TCL_ERROR;
  516.     }
  517.  
  518.     /*
  519.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  520.      * switch in the Makefile.
  521.      */
  522.  
  523.     strcpy(iPtr->result, TCL_VERSION);
  524.     return TCL_OK;
  525.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  526.     Tcl_HashTable *tablePtr;
  527.     char *name;
  528.  
  529.     if (argc > 3) {
  530.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  531.             argv[0], " vars [pattern]\"", (char *) NULL);
  532.         return TCL_ERROR;
  533.     }
  534.     if (iPtr->varFramePtr == NULL) {
  535.         tablePtr = &iPtr->globalTable;
  536.     } else {
  537.         tablePtr = &iPtr->varFramePtr->varTable;
  538.     }
  539.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  540.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  541.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  542.         if (varPtr->flags & VAR_UNDEFINED) {
  543.         continue;
  544.         }
  545.         name = Tcl_GetHashKey(tablePtr, hPtr);
  546.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  547.         continue;
  548.         }
  549.         Tcl_AppendElement(interp, name, 0);
  550.     }
  551.     return TCL_OK;
  552.     } else {
  553.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  554.         "\": should be args, body, cmdcount, commands, ",
  555.         "complete, default, ",
  556.         "exists, globals, level, library, locals, procs, ",
  557.         "script, tclversion, or vars",
  558.         (char *) NULL);
  559.     return TCL_ERROR;
  560.     }
  561. }
  562.  
  563. /*
  564.  *----------------------------------------------------------------------
  565.  *
  566.  * Tcl_JoinCmd --
  567.  *
  568.  *    This procedure is invoked to process the "join" Tcl command.
  569.  *    See the user documentation for details on what it does.
  570.  *
  571.  * Results:
  572.  *    A standard Tcl result.
  573.  *
  574.  * Side effects:
  575.  *    See the user documentation.
  576.  *
  577.  *----------------------------------------------------------------------
  578.  */
  579.  
  580.     /* ARGSUSED */
  581. int
  582. Tcl_JoinCmd(dummy, interp, argc, argv)
  583.     ClientData dummy;            /* Not used. */
  584.     Tcl_Interp *interp;            /* Current interpreter. */
  585.     int argc;                /* Number of arguments. */
  586.     char **argv;            /* Argument strings. */
  587. {
  588.     char *joinString;
  589.     char **listArgv;
  590.     int listArgc, i;
  591.  
  592.     if (argc == 2) {
  593.     joinString = " ";
  594.     } else if (argc == 3) {
  595.     joinString = argv[2];
  596.     } else {
  597.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  598.         " list ?joinString?\"", (char *) NULL);
  599.     return TCL_ERROR;
  600.     }
  601.  
  602.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  603.     return TCL_ERROR;
  604.     }
  605.     for (i = 0; i < listArgc; i++) {
  606.     if (i == 0) {
  607.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  608.     } else  {
  609.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  610.     }
  611.     }
  612.     ckfree((char *) listArgv);
  613.     return TCL_OK;
  614. }
  615.  
  616. /*
  617.  *----------------------------------------------------------------------
  618.  *
  619.  * Tcl_LindexCmd --
  620.  *
  621.  *    This procedure is invoked to process the "lindex" Tcl command.
  622.  *    See the user documentation for details on what it does.
  623.  *
  624.  * Results:
  625.  *    A standard Tcl result.
  626.  *
  627.  * Side effects:
  628.  *    See the user documentation.
  629.  *
  630.  *----------------------------------------------------------------------
  631.  */
  632.  
  633.     /* ARGSUSED */
  634. int
  635. Tcl_LindexCmd(dummy, interp, argc, argv)
  636.     ClientData dummy;            /* Not used. */
  637.     Tcl_Interp *interp;            /* Current interpreter. */
  638.     int argc;                /* Number of arguments. */
  639.     char **argv;            /* Argument strings. */
  640. {
  641.     char *p, *element;
  642.     int index, size, parenthesized, result;
  643.  
  644.     if (argc != 3) {
  645.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  646.         " list index\"", (char *) NULL);
  647.     return TCL_ERROR;
  648.     }
  649.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  650.     return TCL_ERROR;
  651.     }
  652.     if (index < 0) {
  653.     return TCL_OK;
  654.     }
  655.     for (p = argv[1] ; index >= 0; index--) {
  656.     result = TclFindElement(interp, p, &element, &p, &size,
  657.         &parenthesized);
  658.     if (result != TCL_OK) {
  659.         return result;
  660.     }
  661.     }
  662.     if (size == 0) {
  663.     return TCL_OK;
  664.     }
  665.     if (size >= TCL_RESULT_SIZE) {
  666.     interp->result = (char *) ckalloc((unsigned) size+1);
  667.     interp->freeProc = (Tcl_FreeProc *) free;
  668.     }
  669.     if (parenthesized) {
  670.     memcpy((VOID *) interp->result, (VOID *) element, size);
  671.     interp->result[size] = 0;
  672.     } else {
  673.     TclCopyAndCollapse(size, element, interp->result);
  674.     }
  675.     return TCL_OK;
  676. }
  677.  
  678. /*
  679.  *----------------------------------------------------------------------
  680.  *
  681.  * Tcl_LinsertCmd --
  682.  *
  683.  *    This procedure is invoked to process the "linsert" Tcl command.
  684.  *    See the user documentation for details on what it does.
  685.  *
  686.  * Results:
  687.  *    A standard Tcl result.
  688.  *
  689.  * Side effects:
  690.  *    See the user documentation.
  691.  *
  692.  *----------------------------------------------------------------------
  693.  */
  694.  
  695.     /* ARGSUSED */
  696. int
  697. Tcl_LinsertCmd(dummy, interp, argc, argv)
  698.     ClientData dummy;            /* Not used. */
  699.     Tcl_Interp *interp;            /* Current interpreter. */
  700.     int argc;                /* Number of arguments. */
  701.     char **argv;            /* Argument strings. */
  702. {
  703.     char *p, *element, savedChar;
  704.     int i, index, count, result, size;
  705.  
  706.     if (argc < 4) {
  707.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  708.         " list index element ?element ...?\"", (char *) NULL);
  709.     return TCL_ERROR;
  710.     }
  711.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  712.     return TCL_ERROR;
  713.     }
  714.  
  715.     /*
  716.      * Skip over the first "index" elements of the list, then add
  717.      * all of those elements to the result.
  718.      */
  719.  
  720.     size = 0;
  721.     element = argv[1];
  722.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  723.     result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
  724.     if (result != TCL_OK) {
  725.         return result;
  726.     }
  727.     }
  728.     if (*p == 0) {
  729.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  730.     } else {
  731.     char *end;
  732.  
  733.     end = element+size;
  734.     if (element != argv[1]) {
  735.         while ((*end != 0) && !isspace(*end)) {
  736.         end++;
  737.         }
  738.     }
  739.     savedChar = *end;
  740.     *end = 0;
  741.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  742.     *end = savedChar;
  743.     }
  744.  
  745.     /*
  746.      * Add the new list elements.
  747.      */
  748.  
  749.     for (i = 3; i < argc; i++) {
  750.     Tcl_AppendElement(interp, argv[i], 0);
  751.     }
  752.  
  753.     /*
  754.      * Append the remainder of the original list.
  755.      */
  756.  
  757.     if (*p != 0) {
  758.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  759.     }
  760.     return TCL_OK;
  761. }
  762.  
  763. /*
  764.  *----------------------------------------------------------------------
  765.  *
  766.  * Tcl_ListCmd --
  767.  *
  768.  *    This procedure is invoked to process the "list" Tcl command.
  769.  *    See the user documentation for details on what it does.
  770.  *
  771.  * Results:
  772.  *    A standard Tcl result.
  773.  *
  774.  * Side effects:
  775.  *    See the user documentation.
  776.  *
  777.  *----------------------------------------------------------------------
  778.  */
  779.  
  780.     /* ARGSUSED */
  781. int
  782. Tcl_ListCmd(dummy, interp, argc, argv)
  783.     ClientData dummy;            /* Not used. */
  784.     Tcl_Interp *interp;            /* Current interpreter. */
  785.     int argc;                /* Number of arguments. */
  786.     char **argv;            /* Argument strings. */
  787. {
  788.     if (argc < 2) {
  789.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  790.         " arg ?arg ...?\"", (char *) NULL);
  791.     return TCL_ERROR;
  792.     }
  793.     interp->result = Tcl_Merge(argc-1, argv+1);
  794.     interp->freeProc = (Tcl_FreeProc *) free;
  795.     return TCL_OK;
  796. }
  797.  
  798. /*
  799.  *----------------------------------------------------------------------
  800.  *
  801.  * Tcl_LlengthCmd --
  802.  *
  803.  *    This procedure is invoked to process the "llength" Tcl command.
  804.  *    See the user documentation for details on what it does.
  805.  *
  806.  * Results:
  807.  *    A standard Tcl result.
  808.  *
  809.  * Side effects:
  810.  *    See the user documentation.
  811.  *
  812.  *----------------------------------------------------------------------
  813.  */
  814.  
  815.     /* ARGSUSED */
  816. int
  817. Tcl_LlengthCmd(dummy, interp, argc, argv)
  818.     ClientData dummy;            /* Not used. */
  819.     Tcl_Interp *interp;            /* Current interpreter. */
  820.     int argc;                /* Number of arguments. */
  821.     char **argv;            /* Argument strings. */
  822. {
  823.     int count, result;
  824.     char *element, *p;
  825.  
  826.     if (argc != 2) {
  827.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  828.         " list\"", (char *) NULL);
  829.     return TCL_ERROR;
  830.     }
  831.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  832.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  833.         (int *) NULL);
  834.     if (result != TCL_OK) {
  835.         return result;
  836.     }
  837.     if (*element == 0) {
  838.         break;
  839.     }
  840.     }
  841.     sprintf(interp->result, "%d", count);
  842.     return TCL_OK;
  843. }
  844.  
  845. /*
  846.  *----------------------------------------------------------------------
  847.  *
  848.  * Tcl_LrangeCmd --
  849.  *
  850.  *    This procedure is invoked to process the "lrange" Tcl command.
  851.  *    See the user documentation for details on what it does.
  852.  *
  853.  * Results:
  854.  *    A standard Tcl result.
  855.  *
  856.  * Side effects:
  857.  *    See the user documentation.
  858.  *
  859.  *----------------------------------------------------------------------
  860.  */
  861.  
  862.     /* ARGSUSED */
  863. int
  864. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  865.     ClientData notUsed;            /* Not used. */
  866.     Tcl_Interp *interp;            /* Current interpreter. */
  867.     int argc;                /* Number of arguments. */
  868.     char **argv;            /* Argument strings. */
  869. {
  870.     int first, last, result;
  871.     char *begin, *end, c, *dummy;
  872.     int count;
  873.  
  874.     if (argc != 4) {
  875.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  876.         " list first last\"", (char *) NULL);
  877.     return TCL_ERROR;
  878.     }
  879.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  880.     return TCL_ERROR;
  881.     }
  882.     if (first < 0) {
  883.     first = 0;
  884.     }
  885.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  886.     last = 1000000;
  887.     } else {
  888.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  889.         Tcl_ResetResult(interp);
  890.         Tcl_AppendResult(interp,
  891.             "expected integer or \"end\" but got \"",
  892.             argv[3], "\"", (char *) NULL);
  893.         return TCL_ERROR;
  894.     }
  895.     }
  896.     if (first > last) {
  897.     return TCL_OK;
  898.     }
  899.  
  900.     /*
  901.      * Extract a range of fields.
  902.      */
  903.  
  904.     for (count = 0, begin = argv[1]; count < first; count++) {
  905.     result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  906.         (int *) NULL);
  907.     if (result != TCL_OK) {
  908.         return result;
  909.     }
  910.     if (*begin == 0) {
  911.         break;
  912.     }
  913.     }
  914.     for (count = first, end = begin; (count <= last) && (*end != 0);
  915.         count++) {
  916.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  917.         (int *) NULL);
  918.     if (result != TCL_OK) {
  919.         return result;
  920.     }
  921.     }
  922.  
  923.     /*
  924.      * Chop off trailing spaces.
  925.      */
  926.  
  927.     while (isspace(end[-1])) {
  928.     end--;
  929.     }
  930.     c = *end;
  931.     *end = 0;
  932.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  933.     *end = c;
  934.     return TCL_OK;
  935. }
  936.  
  937. /*
  938.  *----------------------------------------------------------------------
  939.  *
  940.  * Tcl_LreplaceCmd --
  941.  *
  942.  *    This procedure is invoked to process the "lreplace" Tcl command.
  943.  *    See the user documentation for details on what it does.
  944.  *
  945.  * Results:
  946.  *    A standard Tcl result.
  947.  *
  948.  * Side effects:
  949.  *    See the user documentation.
  950.  *
  951.  *----------------------------------------------------------------------
  952.  */
  953.  
  954.     /* ARGSUSED */
  955. int
  956. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  957.     ClientData notUsed;            /* Not used. */
  958.     Tcl_Interp *interp;            /* Current interpreter. */
  959.     int argc;                /* Number of arguments. */
  960.     char **argv;            /* Argument strings. */
  961. {
  962.     char *p1, *p2, *element, savedChar, *dummy;
  963.     int i, first, last, count, result, size;
  964.  
  965.     if (argc < 4) {
  966.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  967.         " list first last ?element element ...?\"", (char *) NULL);
  968.     return TCL_ERROR;
  969.     }
  970.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  971.     return TCL_ERROR;
  972.     }
  973.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  974.     return TCL_ERROR;
  975.     }
  976.     if (first < 0) {
  977.     first = 0;
  978.     }
  979.     if (last < 0) {
  980.     last = 0;
  981.     }
  982.     if (first > last) {
  983.     Tcl_AppendResult(interp, "first index must not be greater than second",
  984.         (char *) NULL);
  985.     return TCL_ERROR;
  986.     }
  987.  
  988.     /*
  989.      * Skip over the elements of the list before "first".
  990.      */
  991.  
  992.     size = 0;
  993.     element = argv[1];
  994.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  995.     result = TclFindElement(interp, p1, &element, &p1, &size,
  996.         (int *) NULL);
  997.     if (result != TCL_OK) {
  998.         return result;
  999.     }
  1000.     }
  1001.     if (*p1 == 0) {
  1002.     Tcl_AppendResult(interp, "list doesn't contain element ",
  1003.         argv[2], (char *) NULL);
  1004.     return TCL_ERROR;
  1005.     }
  1006.  
  1007.     /*
  1008.      * Skip over the elements of the list up through "last".
  1009.      */
  1010.  
  1011.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  1012.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  1013.         (int *) NULL);
  1014.     if (result != TCL_OK) {
  1015.         return result;
  1016.     }
  1017.     }
  1018.  
  1019.     /*
  1020.      * Add the elements before "first" to the result.  Be sure to
  1021.      * include quote or brace characters that might terminate the
  1022.      * last of these elements.
  1023.      */
  1024.  
  1025.     p1 = element+size;
  1026.     if (element != argv[1]) {
  1027.     while ((*p1 != 0) && !isspace(*p1)) {
  1028.         p1++;
  1029.     }
  1030.     }
  1031.     savedChar = *p1;
  1032.     *p1 = 0;
  1033.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1034.     *p1 = savedChar;
  1035.  
  1036.     /*
  1037.      * Add the new list elements.
  1038.      */
  1039.  
  1040.     for (i = 4; i < argc; i++) {
  1041.     Tcl_AppendElement(interp, argv[i], 0);
  1042.     }
  1043.  
  1044.     /*
  1045.      * Append the remainder of the original list.
  1046.      */
  1047.  
  1048.     if (*p2 != 0) {
  1049.     if (*interp->result == 0) {
  1050.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1051.     } else {
  1052.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1053.     }
  1054.     }
  1055.     return TCL_OK;
  1056. }
  1057.  
  1058. /*
  1059.  *----------------------------------------------------------------------
  1060.  *
  1061.  * Tcl_LsearchCmd --
  1062.  *
  1063.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1064.  *    See the user documentation for details on what it does.
  1065.  *
  1066.  * Results:
  1067.  *    A standard Tcl result.
  1068.  *
  1069.  * Side effects:
  1070.  *    See the user documentation.
  1071.  *
  1072.  *----------------------------------------------------------------------
  1073.  */
  1074.  
  1075.     /* ARGSUSED */
  1076. int
  1077. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1078.     ClientData notUsed;            /* Not used. */
  1079.     Tcl_Interp *interp;            /* Current interpreter. */
  1080.     int argc;                /* Number of arguments. */
  1081.     char **argv;            /* Argument strings. */
  1082. {
  1083.     int listArgc;
  1084.     char **listArgv;
  1085.     int i, match;
  1086.  
  1087.     if (argc != 3) {
  1088.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1089.         " list pattern\"", (char *) NULL);
  1090.     return TCL_ERROR;
  1091.     }
  1092.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1093.     return TCL_ERROR;
  1094.     }
  1095.     match = -1;
  1096.     for (i = 0; i < listArgc; i++) {
  1097.     if (Tcl_StringMatch(listArgv[i], argv[2])) {
  1098.         match = i;
  1099.         break;
  1100.     }
  1101.     }
  1102.     sprintf(interp->result, "%d", match);
  1103.     ckfree((char *) listArgv);
  1104.     return TCL_OK;
  1105. }
  1106.  
  1107. /*
  1108.  *----------------------------------------------------------------------
  1109.  *
  1110.  * Tcl_LsortCmd --
  1111.  *
  1112.  *    This procedure is invoked to process the "lsort" Tcl command.
  1113.  *    See the user documentation for details on what it does.
  1114.  *
  1115.  * Results:
  1116.  *    A standard Tcl result.
  1117.  *
  1118.  * Side effects:
  1119.  *    See the user documentation.
  1120.  *
  1121.  *----------------------------------------------------------------------
  1122.  */
  1123.  
  1124.     /* ARGSUSED */
  1125. int
  1126. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1127.     ClientData notUsed;            /* Not used. */
  1128.     Tcl_Interp *interp;            /* Current interpreter. */
  1129.     int argc;                /* Number of arguments. */
  1130.     char **argv;            /* Argument strings. */
  1131. {
  1132.     int listArgc;
  1133.     char **listArgv;
  1134.  
  1135.     if (argc != 2) {
  1136.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1137.         " list\"", (char *) NULL);
  1138.     return TCL_ERROR;
  1139.     }
  1140.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1141.     return TCL_ERROR;
  1142.     }
  1143.     qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
  1144.     interp->result = Tcl_Merge(listArgc, listArgv);
  1145.     interp->freeProc = (Tcl_FreeProc *) free;
  1146.     ckfree((char *) listArgv);
  1147.     return TCL_OK;
  1148. }
  1149.  
  1150. /*
  1151.  * The procedure below is called back by qsort to determine
  1152.  * the proper ordering between two elements.
  1153.  */
  1154.  
  1155. static int
  1156. SortCompareProc(first, second)
  1157.     CONST VOID *first, *second;        /* Elements to be compared. */
  1158. {
  1159.     return strcmp(*((char **) first), *((char **) second));
  1160. }
  1161.